home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / PBDBLIB.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  22KB  |  680 lines
  1. {SECTION ..PbDBLIB }
  2. UNIT PbDBLIB;
  3.  
  4. INTERFACE
  5.  
  6. uses CRT, PbCRT, PbMISC, PbOBJS, PbPARMS,
  7.               PbXBASE, PbDBOBJ, PbMEMO;
  8.  
  9.  
  10. {
  11. Description : Higher level xBase utilities
  12.  
  13. Author      : Howard Richoux
  14. Date        : 12/14/93
  15. Last revised: 12/20/93 hnr minor changes
  16.               12/23/93 hnr DBCREATE code
  17. Application : IBM PC and compatibles, done in Turbo Pascal 7
  18. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  19. Published in: none
  20. }
  21.  
  22. var PbDBLIBDebug  : boolean;
  23. var LChar, RChar, SepChar : char;
  24.  
  25. var DBFKeytag          : string[3];   { ext for index file }
  26.     DBFKeySpec         : string;      { field list for key }
  27.     DBFFstring         : string;      { field list for dump/extracts }
  28.     DBFKeyValue        : string;      { search string }
  29.     DBFFlist           : HOLD_object; { parsed Fstring in hold array }
  30.     DBFKeyMax          : integer;     { max recs in key file }
  31.  
  32.  
  33. Procedure DBFGetParms;
  34.                 {[DBF] Fetches standard PbDBLIB fields from parms}
  35.  
  36. Procedure DBFAddParms;
  37.                 {[DBF] Adds standard PbDBLIB fields from parms}
  38.  
  39. Function  DBFDecodeFldName(var x : DBF_object; nam : string) : integer;
  40.                 {[DBF] Fetches Field# given field Name}
  41.  
  42. Procedure DBFDecodeFString(fstring : string;var x : DBF_object;
  43.                            var flist : HOLD_object);
  44.                 {[DBF] xlates fstring into field list}
  45.  
  46. Function  DBFFmtDumpRecNum(recno : integer; typ : byte;
  47.           trimflag,recnumflag : boolean; between : string) : string;
  48.                 {[DBF] Formats the record number - for DBDUMP}
  49.  
  50. Function  DBFFmtDumpRec(var x : DBF_object; var flist : HOLD_object;
  51.                    trimflag,recnumflag : boolean; between : string) : string;
  52.                 {[DBF] Formats a record from a field list - for DBDUMP}
  53.  
  54. Procedure DBFDecodeFieldDef(str : string; var name : string;
  55.                          var fldtyp : char; var ln,decp : integer);
  56.                   {[DBF] Decodes the ExportHeader format }
  57.  
  58. Procedure DBFGetFldInfoByNum(var x : DBF_object; n : integer; var name : string;
  59.                          var fldtyp : char; var ln,decp : integer);
  60.                   {[DBF] Retrieves info based on FIELD NUMBER }
  61.  
  62. Procedure DBFGetFldInfoByName(var x : DBF_object; name : string; var n : integer;
  63.                          var fldtyp : char; var ln,decp : integer);
  64.                   {[DBF] Retrieves info based on NAME }
  65.  
  66. Function  DBFExportHeaderStr(var x : DBF_object;
  67.                              var flist : HOLD_object) : string;
  68.                   {[DBF] Produces "[<FIELDNAM>(<typ><len>),...]" }
  69.  
  70.  
  71.  
  72. Procedure DBFShowStructure(fn : string);
  73.                   {[DBF] for visual Verification }
  74.  
  75. Procedure DBFGetClosedFileInfo(fn : string; var recs,fields,recsize : integer;
  76.                                eof : longint);
  77.                   {[DBF] File opened then closed }
  78.  
  79. Function  DBFValidDBFFile(fn : string) : boolean;
  80.                   {[DBF] for program Verification, checks version byte }
  81.  
  82.  
  83. Procedure DBFCreateFieldHeaders(var fil : file;dbfspec : string;
  84.                                var fields,recbytes : integer);
  85.                   {[DBF] support for DBFCreateFile }
  86.  
  87. Function  DBFCreateFile(dbfname ,dbfspec : string;var err : integer) : boolean;
  88.                   {[DBF] Creates empty file from DBFSPEC=[aa(c10),bb(n4.2)...] }
  89.  
  90. Function  DBFCloneFile(fn1,fn2 : string) : boolean;
  91.                   {[DBF] Header duped, no records }
  92.  
  93. Function  DBFZapFile(fname : string) : boolean;
  94.                   {[DBF] Keeps original as .BAK }
  95.  
  96.  
  97. Function  DBFCopyRecords(fn1,fn2,keytag,keyspec : string;
  98.                         var copied,skipped : longint) : boolean;
  99.                   {[DBF] copies all non deleted from 1 to 2 }
  100.  
  101. Function DBFSORTFile(fname,keytag,keyspec : string) : boolean;
  102.                   {[DBF] sorts DBF file based on tag/spec }
  103.  
  104.  
  105.  
  106. IMPLEMENTATION
  107.  
  108. var dbf1 : KEYED_DBF_object;
  109. var dbf2 : DBF_object;
  110.  
  111.  
  112. Function DBFDecodeFldName(var x : DBF_object; nam : string) : integer;
  113.                 {[DBF] Fetches Field# given field Name}
  114. var s   : string;
  115.     fld : integer;
  116.      begin
  117.      s := nam;
  118.      if (length(s) > 0) and (s[1] = '#') then
  119.           begin
  120.           delete(s,1,1);
  121.           fld := strint(s);
  122.           end
  123.      else fld := x.dbf.dbfldno(s);
  124.     { writeln('DBFDecodeFldName ',nam,' ',fld);}
  125.      DBFDecodeFldName  := fld;
  126.      end;
  127.  
  128.  
  129. Procedure DBFDecodeFString(fstring : string;var x : DBF_object;
  130.                            var flist : HOLD_object);
  131. var s,s1,s2  : string;
  132.     i,l  : integer;
  133.     ch : char;
  134.     begin
  135.     s := UpCaseStr(fstring);
  136.     if s = '[*]' then    {all fields in order - limit 127}
  137.          begin
  138.          for i := 1 to x.dbf.no_col do
  139.               begin
  140.               s1 := '#' + integerstr(i,3);
  141.               removeblanks(s1);
  142.               flist.append(s1,0);
  143.               end;
  144.          end
  145.     else begin
  146.          if s[1] = LChar then delete(s,1,1);
  147.          if s[length(s)] = RChar then delete(s,length(s),1);
  148.          while length(s) > 0 do
  149.               begin
  150.               s1 := GetLeftStr(s,SepChar);
  151.               s2 := GetDelimitedStr(s1,'(',')');
  152.               l  := GetINteger(s2);
  153.               flist.append(s1,l);
  154.               end;
  155.          end;
  156.     end;
  157.  
  158.  
  159.  
  160. Function DBFFmtDumpRecNum(recno : integer; typ : byte;
  161.           trimflag,recnumflag : boolean; between : string) : string;
  162.                 {[DBF] Formats the record number - for DBDUMP}
  163. var s,s1 : string;
  164.      begin
  165.      if      typ = 0 then s1 := '    '
  166.      else if typ = 1 then s1 := 'Rec#'
  167.      else if typ = 2 then s1 := '----'
  168.      else if typ = 3 then s1 := integerstr(recno,4);
  169.      if trimflag then trim(s1);
  170.      s := s1+between;
  171.      if recnumflag then s := s1 + between
  172.      else s := '';
  173.      DBFFmtDumpRecNum := s;
  174.      end;
  175.  
  176.  
  177. Function DBFFmtDumpRec(var x : DBF_object; var flist : HOLD_object;
  178.                    trimflag,recnumflag : boolean; between : string) : string;
  179.                 {[DBF] Formats a record from a field list - for DBDUMP}
  180. var s,s1,nam : string;
  181. var j,fld,len  : integer;
  182.      begin
  183.      s := DBFFmtDumpRecNum(x.dbf.db_rec_no,3,trimflag,recnumflag,between);
  184.      j := 1;
  185.      while (j <= flist.count) and (j <= x.dbf.dbnumfields) do
  186.          begin
  187.          nam := flist.fetchstrN(j);
  188.          fld := DBFDecodeFldName(x,nam);
  189.          if fld > 0 then
  190.               begin
  191.               s1  := x.dbf.dbstr(fld);
  192.               len := flist.fetchnumN(j);
  193.               if len > 0 then s1 := leftstr(s1,len);
  194.               end
  195.          else s1 := '';
  196.          if trimflag then trim(s1);
  197.          s := s + s1 + between;
  198.          inc(j);
  199.          end;
  200.      if j > 1 then delete(s,(length(s)-length(between))+1,length(between));
  201.      DBFFmtDumpRec := s;
  202.      end;
  203.  
  204.  
  205.  
  206. Procedure DBFDecodeFieldDef(str : string; var name : string;
  207.                          var fldtyp : char; var ln,decp : integer);
  208. var s,s1 : string;
  209.     ch   : char;
  210.     i    : integer;
  211.      begin
  212.      name := '';fldtyp := 'C'; ln := 0; decp := 0;
  213.      s := str;
  214.      name := GetLeftStr(s,'(');
  215.      if length(s) < 1 then exit;
  216.      fldtyp := s[1];
  217.      delete(s,1,1);
  218.      if s[length(s)] = ')' then delete(s,length(s),1);
  219.      s1 := GetLeftStr(s,'.');
  220.      ln := strint(s1);
  221.      decp := strint(s);
  222.      end;
  223.  
  224.  
  225. Procedure DBFGetFldInfoByNum(var x : DBF_object; n : integer; var name : string;
  226.                          var fldtyp : char; var ln,decp : integer);
  227. var s : string;
  228.      begin
  229.      s := x.exportfielddefn(n);
  230.      DBFDecodeFielddef(s,name,fldtyp,ln,decp);
  231.      end;
  232.  
  233.  
  234.  
  235. Procedure DBFGetFldInfoByName(var x : DBF_object; name : string; var n : integer;
  236.                          var fldtyp : char; var ln,decp : integer);
  237. var s : string;
  238.      begin
  239.      n := x.dbf.dbfldno(name);
  240.      s := x.exportfielddefn(n);
  241.      DBFDecodeFielddef(s,name,fldtyp,ln,decp);
  242.      end;
  243.  
  244.  
  245.  
  246. Function  DBFExportHeaderStr(var x : DBF_object;
  247.                              var flist : HOLD_object) : string;
  248. var i,j,n : integer;
  249.     s   : string;
  250.      begin
  251.      s := '[';
  252.      n := min(x.dbf.no_col,flist.count);
  253.      i := 0;
  254.      while (i <= n) do
  255.          begin
  256.          inc(i);
  257.          j := DBFDecodeFldName(x,flist.fetchstrN(i));
  258.          s := s + x.exportfielddefn(j);
  259.          if i < n then s := s + ',';
  260.          end;
  261.      s := s + ']';
  262.      DBFExportHeaderStr := s;
  263.      end;
  264.  
  265.  
  266. Procedure DBFShowStructure(fn : string);
  267. var d : XBASE_DBF_object;
  268.      begin
  269.      d.init(fn,dbREADONLY);
  270.      if d.err = 0 then
  271.           begin
  272.           d.dbshowstruc;
  273.           end
  274.      else writeln('Unable to open database [',fn,']');
  275.      d.done;
  276.      end;
  277.  
  278.  
  279. Procedure DBFGetClosedFileInfo(fn : string; var recs,fields,recsize : integer;
  280.                                eof : longint);
  281. var d : XBASE_DBF_object;
  282.      begin
  283.      d.init(fn,dbREADONLY);
  284.      if d.err = 0 then
  285.           begin
  286.           fields  := d.no_col;
  287.           recs    := d.dbhead.no_rec;
  288.           recsize := d.dbhead.rec_bytes;
  289.           eof     := SizeofFile(fn,'');
  290.           end
  291.      else writeln('Unable to open database [',fn,']');
  292.      d.done;
  293.      end;
  294.  
  295.  
  296. Function  DBFValidDBFFile(fn : string) : boolean;
  297. var d : XBASE_DBF_object;
  298. var fields, recs, recsize : integer;
  299.     eof                   : longint;
  300.      begin
  301.      DBFValidDBFFile := false;
  302.      d.init(fn,dbREADONLY);
  303.      if d.err = 0 then
  304.           begin
  305.           if (d.dbhead.dbvno = 3) or (d.dbhead.dbvno = 131) then
  306.                DBFValidDBFFile := true;
  307.           end;
  308.      d.done;
  309.      end;
  310.  
  311. {PAGE}
  312.  
  313.  
  314. Procedure DBFCreateFieldHeaders(var fil : file;dbfspec : string;
  315.                                var fields,recbytes : integer);
  316. var s,s1,s2,fldnam : string;
  317. var err,numwritten,i : integer;
  318.     ch  : char;
  319.     fld : db4ref_type;
  320.     ok  : boolean;
  321.      begin
  322.      fields := 0; recbytes := 1; { delete flag }
  323.      s := UpCaseStr(dbfspec);
  324.      if s[1] = LChar then delete(s,1,1);
  325.      if s[length(s)] = RChar then s[length(s)] := ',';
  326.      while length(s) > 0 do
  327.           begin
  328.           fillchar(fld,sizeof(fld),0);
  329.           s1 := GetLeftStr(s,SEPChar);
  330.           s2 := GetDelimitedStr(s1,'(',')');
  331.           fldnam := s1;
  332.           fld.rtype := s2[1];
  333.           delete(s2,1,1);
  334.           if fld.rtype = 'N' then
  335.                begin
  336.                i := pos('.',s2);
  337.                if i > 0 then
  338.                     begin
  339.                     fld.width := strint(leftstr(s2,i-1));
  340.                     delete(s2,1,i);
  341.                     fld.decp := strint(s2);
  342.                     end
  343.                else fld.width := strint(s2);
  344.                end
  345.           else if fld.rtype = 'D' then fld.width := 8
  346.           else if fld.rtype = 'M' then fld.width := 10
  347.           else fld.width := strint(s2);
  348.           recbytes := recbytes + fld.width;
  349.           move(s1[1],fld.name,length(s1));
  350.           inc(fields);
  351.           ok :=  MyBlockWrite(fil,fld,sizeof(fld),numwritten,err);
  352.           end;
  353.  
  354.      { I still don't know why these 2 extra bytes }
  355.      fld.name[1] := chr(13);
  356.      fld.name[2] := chr(0);
  357.      ok :=  MyBlockWrite(fil,fld,2,numwritten,err);
  358.      end;
  359.  
  360.  
  361. Function  DBFCreateFile(dbfname ,dbfspec : string;var err : integer) : boolean;
  362. var numwritten,fields,recsize : integer;
  363. var fil   : file;
  364.     hd    : db4head_type;
  365.     ok    : boolean;
  366.      begin
  367.      DBFCreateFile := false;
  368.      if length(dbfspec) < 3 then
  369.           begin
  370.           err:=999;
  371.           writeln('No Fields specified, Stopping DBCREATE  [',dbfspec,']');
  372.           exit;
  373.           end;
  374.      if not MyOpenFileCreate(fil,dbfname,1,err) then exit;
  375.  
  376.      fillchar(hd,sizeof(hd),0);
  377.      hd.dbvno  := $83;
  378.      hd.no_rec := 0;
  379.      hd.header_bytes := 32;
  380.      SetDateBytes(hd.updyr,hd.updmo,hd.upddy);
  381.      if not MyBlockWrite(fil,hd,sizeof(hd),numwritten,err) then
  382.           begin ok := MyCloseFile(fil,err); exit; end;
  383.  
  384.      DBFCreateFieldHeaders(fil,dbfspec,fields,recsize);
  385.  
  386.      if not MySeek(fil,0,err) then
  387.           begin ok := MyCloseFile(fil,err); exit; end;
  388.      hd.header_bytes := (fields+1)*32+2;  {32 hdr + fields*32 + 2 extra btyes}
  389.      hd.rec_bytes    := recsize;
  390.      if not MyBlockWrite(fil,hd,sizeof(hd),numwritten,err) then
  391.           begin ok := MyCloseFile(fil,err); exit; end;
  392.  
  393.      ok := MyCloseFile(fil,err);
  394.      DBFCreateFile := true;
  395.      end;
  396.  
  397. {PAGE}
  398.  
  399. Function DBFCloneFile(fn1,fn2 : string) : boolean;
  400.             { Copies Structure, not records }
  401. var fname1, fname2   : string;
  402.     oldfile, newfile : file;
  403.     fhdr             : db4head_type;     { general file info}
  404.     fldhdr           : db4ref_type;      { holds 1 field definition}
  405.     error, numfields : integer;
  406.     numread, i       : integer;
  407.     hdrsize            : integer;
  408.      begin
  409.      DBFCloneFile := false;
  410.      fname1 := fn1;
  411.      if not DBFValidDBFfile(fname1) then
  412.           begin
  413.           writeln('Invalid version # - Cannot clone this file [',fname1,']');
  414.           exit;
  415.           end;
  416.      if not MyOpenFileExisting(oldfile,fname1,1,fREADONLY,error) then exit;
  417.      if PbDBLIBDebug then
  418.           writeln('ok to clone 1 old file found [',fname1,']');
  419.  
  420.      fname2 := fn2;
  421.      if not MyOpenFileCreate(newfile,fname2,1,error) then
  422.           begin close(oldfile); exit;  end;
  423.      if PbDBLIBDebug then
  424.           writeln('ok to clone 2 new file not found [',fname2,']');
  425.  
  426. {Copy file header, resetting some variables }
  427.      if not MyBlockRead(oldfile,fhdr,sizeof(fhdr),numread,error) then
  428.      if (error <> 0) or (numread <> sizeof(fhdr)) then
  429.           begin
  430.           writeln('Unable to clone file - header read error= ',error,
  431.                   '   numread= ',numread);
  432.           exit;
  433.           end;
  434.  
  435.      fhdr.no_rec := 0;                              { no data records}
  436.      SetDateBytes(fhdr.updyr,fhdr.updmo,fhdr.upddy); { last update date}
  437.      hdrsize := fhdr.header_bytes;
  438.  
  439.      if not MyBlockWrite(newfile,fhdr,sizeof(fhdr),numread,error) then
  440.           begin
  441.           writeln('Unable to clone file - header read error= ',error,
  442.                   '   numread= ',numread);
  443.           exit;
  444.           end;
  445.      if PbDBLIBDebug then
  446.           writeln('new file header written   file size=',filesize(newfile));
  447.  
  448. { Now copy the field definitions }
  449.      numfields := (fhdr.header_bytes-sizeof(fhdr)) div 32;
  450.      if PbDBLIBDebug then
  451.           writeln('Header bytes    = ',fhdr.header_bytes,
  452.                   '  Number of fields= ',numfields);
  453.      for i := 1 to numfields do
  454.           begin
  455.           if MyBlockRead(oldfile,fldhdr,sizeof(fldhdr),numread,error) then
  456.                begin
  457.                if not MyBlockWrite(newfile,fldhdr,sizeof(fldhdr),
  458.                                    numread,error) then begin end;
  459.                end;
  460.           end;
  461.  
  462.      fldhdr.name[1] := chr(13);
  463.      if not MyBlockWrite(newfile,fldhdr,1,numread,error) then
  464.           begin end;  { extra bytes for some reason }
  465.      if filesize(newfile) < (hdrsize) then
  466.           begin
  467.           while (filesize(newfile) < (hdrsize)) do
  468.                begin
  469.                fldhdr.name[1] := chr(0);
  470.                if not MyBlockWrite(newfile,fldhdr,1,numread,error) then
  471.                     begin end;  { extra bytes for some reason }
  472.                end;
  473.           end;
  474.      if PbDBLIBDebug then
  475.           writeln('done writing header. file size= ',filesize(newfile));
  476.  
  477.      {$I-} close(oldfile); {$I+}
  478.      error := IOResult;
  479.      if error <> 0 then writeln('Close error (oldfile) ',error);
  480.      {$I-} close(newfile); {$I+}
  481.      error := IOResult;
  482.      if error <> 0 then writeln('Close error (newfile) ',error);
  483.  
  484.      DBFCloneFile := true;
  485.      end;
  486.  
  487.  
  488. Function DBFZapFile(fname : string) : boolean;
  489. var fn1,fn2 : string;
  490.      begin
  491.      DBFZapFile := true;
  492.      fn1 := fname;
  493.      fn2 := fname;
  494.      forceext(fn2,'tmp');
  495.      erasefile(fn2);
  496.      if DBFCloneFile(fn1,fn2) then
  497.           begin
  498.           if PbDBLIBDebug then writeln('Cloned OK.');
  499.           if not ForceRenameToBAK(fn1) then
  500.                begin
  501.                DBFZapFile := false;
  502.                writeln('Unable to back up the original file - Cancelling ZAP',
  503.                        '[',fn1,']');
  504.                end
  505.           else begin
  506.                if PbDBLIBDebug then
  507.                     writeln('Renamed to bak [',fn1,']  OK. ');
  508.                if not RenameFile(fn2,fname) then
  509.                     begin
  510.                     DBFZapFile := false;
  511.                     writeln('Unable to rename new file [',fn2,'] [',
  512.                              fname,']');
  513.                     end
  514.                else if PbDBLIBDebug then
  515.                          writeln('Renamed [',fn2,'] to [',fname,'] OK. ');
  516.                end;
  517.           end
  518.      else begin
  519.           DBFZapFile := false;
  520.           writeln('Unable to CLONE file - Cancelling ZAP   [',fname,']');
  521.           end;
  522.      end;
  523.  
  524.  
  525.  
  526. Procedure CopyDbf1ToDbf2(var copied,skipped : longint);
  527. var n  : longint;
  528.     ok : boolean;
  529.      begin
  530.      copied := 0; skipped := 0;
  531.      for n := 1 to dbf1.numrecs do
  532.           begin
  533.           dbf1.fetchn(n);
  534.           if not dbf1.dbf.dbdeleted then
  535.                begin
  536.                move(dbf1.dbf.dbbuf,dbf2.dbf.dbbuf,dbf2.recsize);
  537.                ok := dbf2.append;
  538.                if not ok then
  539.                     begin
  540.                     writeln('Unable to write record ',dbf2.err);
  541.                     exit;
  542.                     end
  543.                else inc(copied);
  544.                end
  545.           else inc(skipped);
  546.           end;
  547.      end;
  548.  
  549.  
  550. Function DBFCopyRecords(fn1,fn2,keytag,keyspec : string;
  551.                         var copied,skipped : longint) : boolean;
  552.      begin
  553.      copied := 0;
  554.      DBFCopyRecords := false;
  555.      dbf1.init(fn1,0,fREADONLY,keytag,keyspec,DBFKeyMax);
  556.      if dbf1.opened then
  557.           begin
  558.           dbf2.init(fn2,0,fREADWRITE);
  559.           if dbf2.opened then
  560.                begin
  561.                CopyDbf1ToDbf2(copied,skipped);
  562.                writeln('Copy done   coppied= ',copied,'   skipped= ',skipped);
  563.                dbf2.done;
  564.                end;
  565.           dbf1.done;
  566.           end;
  567.      DBFCopyRecords := true;
  568.      end;
  569.  
  570. {PAGE}
  571.  
  572. {
  573. Notes on SORT:
  574.   1. The file being sorted must be named <name>.DBF
  575.      The KEYTAG OR KEYSPEC must be specified in the .CFG  file
  576.      or on the command line.  If both are specified, only the DBFKeyTag is
  577.      used.
  578.   2. Next, the <name>.DBF file is cloned to <name>.NEW.  This copies the
  579.        structure, but not the records.
  580.   3. Now, the .DBF file is opened using the key specified. If a valid KEY
  581.        file exists, it is used, otherwise, it is created.
  582.   4. The .DBF file is read in key order and written to the .NEW file.
  583.        Deleted records are skipped.
  584.   5. Both files are closed.
  585.   6. <name>.DBF is force renamed to <name>.BAK.  <name>.NEW is renamed
  586.       to <name>.DBF.
  587.   8. Any existing keytag files will be dated prior to the DBF, and will
  588.       be re-created next time they are used.
  589. }
  590.  
  591. Function DBFSORTFile(fname,keytag,keyspec : string) : boolean;
  592. var fn1,fn2 : string;
  593.     copied,skipped  : longint;
  594.      begin
  595.      DBFSortFile := true;
  596.      fn1 := fname;
  597.      fn2 := fname;
  598.      forceext(fn2,'NEW');
  599.      erasefile(fn2);
  600.      if DBFCloneFile(fn1,fn2) then
  601.           begin
  602.           if PbDBLIBDebug then writeln('Cloned OK.');
  603.           if DBFCopyRecords(fn1,fn2,keytag,keyspec,copied,skipped) then
  604.                begin
  605.                if PbDBLIBDebug then
  606.                     writeln(copied, ' Records copied OK. ');
  607.                if PbDBLIBDebug then
  608.                     writeln(skipped, ' Records skipped. ');
  609.                end
  610.           else begin
  611.                writeln('Unable to copy records from [',fn1,'] to [',fn2,
  612.                        '] - Cancelling SORT');
  613.                exit;
  614.                end;
  615.           if not ForceRenameToBAK(fn1) then
  616.                begin
  617.                DBFSortFile := false;
  618.                writeln('Unable to back up the original file - Cancelling Sort',
  619.                        '[',fn1,']');
  620.                end
  621.           else begin
  622.                if PbDBLIBDebug then
  623.                     writeln('Renamed to bak [',fn1,']  OK. ');
  624.                if not RenameFile(fn2,fname) then
  625.                     begin
  626.                     DBFSortFile := false;
  627.                     writeln('Unable to rename new file [',fn2,'] [',
  628.                              fname,']');
  629.                     end
  630.                else if PbDBLIBDebug then
  631.                          writeln('Renamed [',fn2,'] to [',fname,'] OK. ');
  632.                end;
  633.           end
  634.      else begin
  635.           DBFSortFile := false;
  636.           writeln('Unable to CLONE file - Cancelling Sort   [',fname,']');
  637.           end;
  638.      end;
  639.  
  640.  
  641. {PAGE}
  642.  
  643. Procedure DBFGetParms;
  644.      begin
  645.      DBFFstring     := GetParmStr('FIELDS');
  646.      DBFKeySpec     := GetParmStr('KEYSPEC');
  647.      DBFKeytag      := GetParmStr('KEYTAG');
  648.      DBFKeyValue    := GetParmStr('KEYVALUE');
  649.      DBFKeyMax      := GetParmNum('INDEXMAX');
  650.      end;
  651.  
  652.  
  653. Procedure DBFAddParms;
  654.      begin
  655.      AddParm(1,'FIELDS','[*]');    { all fields in order }
  656.      AddParm(1,'KEYSPEC','');
  657.      AddParm(1,'KEYVALUE','*');    { match everything }
  658.      AddParm(1,'KEYTAG','');
  659.      AddParm(1,'INDEXMAX','5000');
  660.      end;
  661.  
  662.  
  663. Procedure PbDBLIBInit;
  664.      begin
  665.      DBFFstring     := '';
  666.      DBFKeySpec     := '';
  667.      DBFKeyValue    := '';
  668.      DBFKeytag      := '';
  669.      DBFKeyMax      := 5000;
  670.      PbDBLIBDebug := false;
  671.      LChar := '[';
  672.      RChar := ']';
  673.      Sepchar := ',';
  674.      end;
  675.  
  676.  
  677.      begin {initialization}
  678.      PbDBLIBinit;
  679.      end.
  680.